home *** CD-ROM | disk | FTP | other *** search
- unit Assertions;
-
- interface
-
- {$IFC MACTARGET}
- uses
- Types, Dialogs, Processes, TextUtils;
- {$ENDC}
-
- {$IFC WINTARGET}
- uses
- MyWinUtils;
- {$ENDC}
-
-
- const
- DEBUG_ALERT_ID = 24576; { debugging alert, must be included in resource file with the }
- { following items: 1 to continue, 2 to terminate and at least one StaticText with ^1 for}
- { the message string. }
-
- { Useful compile-time variables }
-
- {$ifc undefined PROGICIEL_R_4}
- {$setc PROGICIEL_R_4 := true}
- {$endc}
-
- { Use threads or not? }
- { Threads are broken under Think Pascal 4.02 }
- {$setc can_use_threads := true}
- {$ifc THINK_PASCAL}
- {$setc can_use_threads := false}
- {$endc}
-
- {$ifc undefined do_debug}
- {$setc do_debug := 1}
- {$endc}
-
- {$ifc undefined do_showmem}
- {$setc do_showmem := 1}
- {$endc}
-
- {$ifc undefined do_debugfiles}
- {$setc do_debugfiles := 1}
- {$endc}
-
- {$setc do_showmem := 0}
- {$setc do_debugfiles := 0}
-
-
- {$IFC MACTARGET}
-
- {$ifc not do_debug}
- { Do this only under THINK Pascal, since it's linked out in CW with the definec }
- {$IFC THINK_PASCAL}
- procedure Assert (b: Boolean);
- {$endc}
- {$definec Assert(b)}
- {$elsec}
- {$definec Assert(b) AssertCode(b, SrcLine, SrcFile, CompDate, CompTime)}
- {$DEFINEC passert(a) lassert(a,srcfile,srcline)}
- {$endc}
-
- {$ifc do_debug}
-
- {$ifc do_debugfiles}
- var
- debug1, debug2: Text;
- {$endc}
-
- {$IFC THINK_PASCAL}
- procedure Assert (b: boolean);
- {$ELSEC}
- procedure AssertCode (b: boolean; lineNum: LongInt; fileName, cDate, cTime: Str255);
- {$ENDC}
-
- {$endc}
-
- {$ENDC}
-
- {$IFC WINTARGET}
- procedure Assert (b: Boolean);
- {$ENDC}
-
- procedure MyDebugStr (msg: Str255);
-
- implementation
-
- {$IFC MACTARGET}
-
- { How to tell if MacsBug is Installed }
- { This is a small snippet of code that can be used to to detect if }
- { macsbug is installed or not. NOTE: This code is intended to only work with }
- { version 6.2 of macsbug. You should refer to your Low Level Debugger's manual }
- { for more information on how they install themselves. }
- { }
- { This code is based on information obtained from the MacsBug Reference. }
- { The basic assumptions are that macsbug will install itself in the following }
- { manner: }
- { }
- { If you are running in 24 bit mode, then the high -order byte of MacJmp is a flags }
- { byte that contains the following information: }
- { appears at location 0xBFF. The code reflects these findings. }
-
-
- function MacsBugInstalled: Boolean;
- const
- BYTEMASK = $20; { Used to detect if bit 5 is set }
- var
- FlagByte: Ptr;
- begin
- FlagByte := Ptr($BFF); { This is used only if running in 32 bit mode }
-
- MacsBugInstalled := (BAnd(LongInt(FlagByte^), BYTEMASK) > 0);
- end;
-
-
- {$ifc do_debug}
- {$IFC THINK_PASCAL}
- procedure Assert;
- {$ELSEC}
- procedure AssertCode;
- {$ENDC}
- var
- dbgStr: Str255;
- {$IFC NOT THINK_PASCAL}
- lineStr: Str255;
- {$ENDC}
- begin
- if not b then begin
- dbgStr := 'Assertion failed';
- {$IFC NOT THINK_PASCAL}
- NumToString(lineNum, lineStr);
- dbgStr := Concat(dbgStr, ' in file ', fileName, ', line: ', lineStr, ' (', cDate, ' at ', cTime, ')');
- {$ENDC}
- dbgStr := Concat(dbgStr, '. Notify casgrain@magellan.umontreal.ca');
- MyDebugStr(dbgStr);
- end;
- end;
- {$elsec}
- { Do this only under THINK Pascal, since it's linked out in CW }
- {$IFC THINK_PASCAL}
- procedure Assert;
- begin
- end;
- {$endc}
- {$endc}
-
- { this procedure displays an alert when debugging is not enabled }
- { it allows to exit the program (losing everything but hopefully not }
- { hosing the system) or continue along. }
- procedure DisplayDebugStr (msg: Str255);
- begin
- ParamText(msg, '', '', '');
- if StopAlert(DEBUG_ALERT_ID, nil) = cancel then
- ExitToShell;
- end;
-
- procedure MyDebugStr (msg: Str255);
- {$ifc do_debug}
- begin
- if MacsBugInstalled then begin
- msg := Concat(msg, ';sc;hc');
- DebugStr(msg);
- end
- else
- DisplayDebugStr(msg);
- end;
- {$elsec}
- begin
- DisplayDebugStr(msg);
- end;
- {$endc}
-
- {$ENDC}
-
- {$IFC WINTARGET}
-
- procedure Assert;
- begin
-
- end;
-
- procedure MyDebugStr;
- begin
-
- end;
-
- {$ENDC}
-
-
- end.